home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 008 / misc_lsp.arc / DWGDAT.LSP < prev    next >
Encoding:
Text File  |  1988-02-21  |  1.9 KB  |  50 lines
  1. (defun C:DATE(/ td time j y d m ys ms ds hh hs mm mss ss sss place rotn rot dwg)
  2.  
  3. ; Richard Henley 73260,2346 Scanlon and Associates, Albuquerque NM
  4. ; Lisp Routine to Place Current Time, Date and Drawing Name at selected
  5. ; location and rotation (entered or picked)
  6. ; The Current Text Height should not be 0
  7.  
  8.         (setq td (getvar "date"))
  9.         (setq time (* 86400.0 (- td (setq j (fix td)))))
  10.         (setq j (- j 1721119.0))
  11.         (setq y (fix (/ (1- (* 4 j)) 146097.0)))
  12.         (setq j (- (* j 4.0) 1.0 (* 146097.0 y)))
  13.         (setq d (fix (/ j 4.0)))
  14.         (setq j (fix (/ (+ (* 4.0 d) 3.0) 1461.0)))
  15.         (setq d (- (+ (* 4.0 d) 3.0) (* 1461.0 j)))
  16.         (setq d (fix (/ (+ d 4.0) 4.0)))
  17.         (setq m (fix (/ (- (* 5.0 d) 3) 153.0)))
  18.         (setq d (- (* 5.0 d) 3.0 (* 153.0 m)))
  19.         (setq d (fix (/ (+ d 5.0) 5.0)))
  20.         (setq y (+ (* 100.0 y) j))
  21.         (if (< m 10.0)
  22.            (setq m (+ m 3))
  23.            (progn
  24.               (setq m (- m 9))
  25.               (setq y (1+ y))
  26.            )
  27.         )
  28.         (setq ys (rtos y 2 0))
  29.         (setq ms (itoa m))
  30.         (setq ds (itoa d))
  31.         (setq hh (fix (/ time 3600.0)))
  32.         (setq hs (itoa hh))
  33.         (setq time (- time (* hh 3600.0)))
  34.         (setq mm (fix (/ time 60.0)))
  35.         (setq mss (itoa mm))
  36.         (setq ss (- time (* mm 60.0)))
  37.         (setq sss (rtos ss 2 0))
  38.         (setq dt (strcat "Date: " ms "/" ds "/" ys))
  39.         (setq dt2 (strcat "Time: " hs ":" mss ":" sss))
  40.         (setq place
  41.          (getpoint "Enter point to place Date/Time/Drawing File Name Stamp: "))
  42.         (setq rotn (getangle place "Enter Text Rotation <0.0>: "))
  43.          (if (null rotn) (setq rot "0.0") (setq rot (angtos rotn 0 6))) 
  44.         (setq dwg (strcat "Drawing File: " (strcase (getvar "dwgname"))))
  45.         (command "text" place rot dt2)
  46.         (command "text" "" dt)
  47.         (command "text" "" dwg)
  48.         (princ)
  49. )
  50.